home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
pascal
/
svgadc30.zip
/
svga.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-03-03
|
42KB
|
1,603 lines
Unit SVGA;
INTERFACE
const
ButtonL = 0; ButtonR = 1; ButtonM = 2;
OFF = 0; ON = 1;
Type
RGB = record
Red, Grn, Blu : byte
end;
PaletteRegister = array[0..255] of RGB;
SetTypes = ( FutureFont, StandardFont );
ResType = ( VGA, SVGA6440, SVGA6448, SVGA8060, SVGA1076 );
Position = record
BtnStatus,
opCount,
XPos, YPos : integer;
end;
EventRec = record
Event,
BtnStatus,
XPos, YPos : word;
end;
YPtr = ^YType;
YType = record
Col1, Col2, Col3, Col4 : byte; { Due to TP's memory }
NextY : YPtr; { memory management }
end; { pointers are multiples}
XPtr = ^XType; { of 8 bytes }
XType = record
NextX : XPtr;
Y : YPtr;
end;
GenMouse = object
procedure SetAccel( threshold : integer );
{ Set Acceleration of mouse }
procedure Getposition( var BtnStatus, XPos, YPos : integer );
{ Gets the Position of the mouse and returns button status }
procedure QueryBtnDn( button : integer; var mouse : Position );
{ Checks if queried button was pressed }
procedure QueryBtnUp( button : integer; var mouse : Position );
{ Checks if queried button is released }
procedure ReadMove( var XMove, YMove : integer );
{ Reports absolute mouse movement since last call to ReadMove }
procedure Reset( var Status : boolean; var BtnCount : integer );
{ Resets the mouse to default conditions }
procedure SetRatio( horPix, verPix : integer );
{ Sets speed of mouse }
procedure SetLimits( XPosMin, YPosMin, XPosMax, YPosMax : integer );
{ Creates View Port for which mouse can operate in }
procedure SetPosition( XPos, YPos : integer );
{ Puts mouse to desired point on screen }
end;
GraphicMouse = object( GenMouse )
procedure Initialize;
{ Sets default conditons for graphics mouse }
procedure Show( ShowM : boolean );
{ Either shows or hides the graphics mouse }
procedure MPlot( xx, yy : integer );
procedure CheckMouse;
{ Checks if mouse has been moved since last call and moves mouse accordingly }
procedure ExitSVGA;
{ Exits Graphics mouse and resets it back to text mode }
end;
procedure SetMode( Mode : Restype );
{ Sets Graphics card to desired mode }
function WhichBank( x, y : integer ): byte;
procedure LoadWriteBank( Segment : byte );
{ Loads particular bank for read/write operations }
procedure Plot( x, y : integer; Color : byte );
{ Plots a point to screen }
procedure PutImage( x, y : integer; Img : XPtr );
{ Puts an image in memory to screen at point (x,y), top left hand corner }
procedure LoadImage( ImageName : string; var ImagePtr : XPtr );
{ Loads image from disk and puts into memory }
procedure DisposeImage( var Img : XPtr );
{ Deletes image from memory }
procedure SetColor( PalNum: byte; Hue : RGB );
{ Sets Color of a particular pallette }
function GetPixel( x, y : integer ) : byte;
{ Returns color of a pixel }
procedure SetPalette( Hue : PaletteRegister );
{ Sets all 256 pallette registers to desired pallette }
procedure CyclePalette;
{ Rotates all colors in the pallette in repetitive cycle }
procedure Circle( x, y, Radius : word; Color : byte );
{ Draws a circle }
procedure Line( xx1, yy1, xx2, yy2 : integer; Color : byte );
{ Draws a line }
procedure ClearDevice;
procedure ClearPort( x1, y1, x2, y2 : integer );
{ Clears a Section of the screen }
procedure Rectangle( x1, y1, x2, y2 : word; Color : byte );
{ Draws a rectangle outline i.e not solid }
procedure RectFill( x1, y1, x2, y2 : integer; Color : byte );
{ Draws a solid Rectangle }
procedure ExitGraphics;
{ Exits SVGA Graphics and returns to normal text mode }
procedure OutTextXY( x, y : integer; word : string );
{ Writes text to screen at point X, Y }
procedure LoadFont( CharSetName: SetTypes );
{ Loads a particular Font for use }
procedure SetFont( Font : SetTypes );
{ If two or more fonts are in memory this allows you to choose one }
procedure SetFontColor( Color, BackCol : byte; Trans : boolean );
{ Set forground & background color of text & transparent background or not }
{ i.e write background to screen or skip it and only write letter }
procedure LoadPalette( PaletteName : string );
{ Loads a particular pallette from disk }
var Color : PaletteRegister;
Bytes_per_Line, GetMaxX, GetMaxY : integer;
mEvent : EventRec;
PresentSeg : byte;
IMPLEMENTATION
Uses Dos, Crt;
type FCharType = array[ 0..15, 0..12 ] of boolean;
FCharSetType = array[ 0..95 ] of FCharType;
SCharType = array[ 0..7, 0..9 ] of boolean;
SCharSetType = array[ 0..95 ] of SCharType;
CardType = ( AheadA, AheadB, ATI, ChipsTech, Everex, Genoa,
Paradise, Trident, Tseng3000, Tseng4000, Video7 );
NameType = string[30];
var
Mxx, Mxy, Mnx, Mny, XRes, YRes, X, Y, OldX, OldY : integer;
regs : registers;
Future : ^FCharSetType;
Standard : ^SCharSetType;
Width, Height, FontColor, BackGroundColor : byte;
PresentSet : SetTypes;
ShowMouse, Transparent, Sused, Fused : boolean;
Card : CardType;
MP, ColOld : array[ 0..3, 0..3 ] of byte;
function Ahead : NameType;
begin
Portw[$3CE] := $200F;
if Port[$3CF] = $20 then Ahead := 'Ahead A'
else if Port[$3CF] = $21 then Ahead := 'Ahead B'
else Ahead := 'False';
end;
function AnATI : NameType;
var s : NameType;
Temp : string;
begin
s[0] := #9;
move(mem[$C000:$31],s[1],9);
if s = '761295520'then
begin
Temp := 'ATI';
if memw[$C000:$40] = $3331 then
begin
Temp := Temp + ' Super VGA';
Regs.AH := $12;
Regs.BX := $5506;
Regs.AL := $55;
Regs.BP := $FFFF;
Regs.SI := $0;
intr( $10, Regs );
if Regs.BP = $FFFF then Temp := Temp + ' Revision 1'
else Temp := Temp + ' Revision 2/3';
end
else
Temp := 'False';
AnATI := Temp;
end
else AnATI := 'False';
end;
function AChipsTech : Nametype;
var OldValue, Value : byte;
Temp : string;
begin
Port[$3C3] := Port[$3C3] or 16;
if Port[$104] = $A5 then
begin
Temp:= 'Chips & Technologies';
Port[$3C3] := Port[$3C3] and $EF;
Port[$3D6] := 0;
case Port[$3D7] shr 4 of
2 : Temp := Temp + ' 82c455';
3 : Temp := Temp + ' 82c453';
5 : Temp := Temp + ' 82c456';
1 : begin
Port[$3D6] := $3A;
OldValue := Port[$3D7];
Port[$3D7] := $AA;
Value := Port[$3D7];
Port[$3D7] := OldValue;
if Value = $AA then Temp := Temp + ' 82c452'
else Temp := Temp + ' 82c451';
end;
end;
AChipsTech := Temp;
end
else AChipsTech := 'False';
end;
function AnEverex : NameType;
var Value : byte;
s : NameType;
begin
Regs.AX := $7000;
Regs.BX := 0;
intr( $10, Regs );
if Regs.AL = $70 then
begin
Value := Regs.DX shr 4;
if Value = $678 then AnEverex := 'Everex Ev678'
else if Value = $236 then AnEverex := 'Everex Ev236'
else begin
str( Value, s );
AnEverex := 'Everex Ev'+ s;
end;
end
else AnEverex := 'False';
end;
function AGenoa : Nametype;
begin
if (meml[$C000:mem[$C000:$37]] and $FFFF00FF) = $66990077 then
begin
case mem[$C000:mem[$C000:$37] + 1] of
$33, $55 : AGenoa := 'Tseng ET3000';
$22 : AGenoa := 'Genoa 610